home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / TUT17.ZIP / TUTPRO17.PAS < prev   
Pascal/Delphi Source File  |  1995-01-17  |  15KB  |  472 lines
  1. {$X+}
  2. USES crt,gfx3;
  3.  
  4. Const jump = 64;       { Number of pixels active at once }
  5.       sjump = 6;       { 1 shl 6 = 64 }
  6.  
  7. TYPE
  8.         FontDat = Array [' '..'Z',1..16,1..16] of byte; {Our main font }
  9.         target = record
  10.                  herex,herey : integer;
  11.                  targx,targy : integer;
  12.                  dy,dx : integer;
  13.                  active : boolean;
  14.                  col : byte;
  15.                  num:integer;
  16.              END;
  17.         PixelDat = Array [1..4095] of target; { This is the maximum number
  18.                                                 of points we canb fit in a
  19.                                                 segment... }
  20.  
  21. VAR Font : ^FontDat;                          { Our nice font }
  22.     nextrow : ^PixelDat;
  23.     scr : array [' '..'Z',1..8,1..8] of byte; { The basic bios font }
  24.     Vir2 : VirtPtr;
  25.     Vaddr2 : Word;                            { Spare virtual screen }
  26.     counter:integer;
  27.     PosLoop:integer;
  28.     dir : boolean;
  29.     pathx,pathy:array [1..314] of integer;    { Path of origination }
  30.     arbpal : array [1..8,1..3] of byte;       { Used to remember certain
  31.                                                 colors }
  32.  
  33.  
  34.  
  35. {──────────────────────────────────────────────────────────────────────────}
  36. Procedure Bigmsg (x,y:integer;msg:string);
  37.   { This draws string msg to screen in the bios font, but bigger }
  38. VAR loop1,loop2,loop3,loop4,loop5:integer;
  39. BEGIN
  40.   for loop1:=1 to length (msg) do
  41.     for loop2:=1 to 8 do
  42.       for loop3:=1 to 8 do
  43.         if (scr[msg[loop1],loop3,loop2]<>0) then BEGIN
  44.           for loop4:=1 to 4 do
  45.             for loop5:=1 to 8 do
  46.               putpixel (x+(loop1*32)+(loop2*4)+loop4,y+(loop3*8)+loop5,
  47.                 getpixel (x+(loop1*32)+(loop2*4)+loop4,y+(loop3*8)+loop5,vaddr2)+51,vaddr);
  48.         END;
  49. END;
  50.  
  51.  
  52.  
  53.  
  54. {──────────────────────────────────────────────────────────────────────────}
  55. Procedure Static;
  56.   { This moves the static and tunes in to our background logo }
  57. VAR loop1,loop2,count,count2,count3:integer;
  58. BEGIN
  59.   flip (vaddr2,vaddr);
  60.   Bigmsg (0,60,'ASPHYXIA');
  61.   flip (vaddr,vga);
  62.   count:=0;
  63.   count2:=0;
  64.   for loop2:=1 to 100 do BEGIN
  65.     waitretrace;
  66.     for loop1:=99 to 150 do BEGIN
  67.       count:=random (64);
  68.       pal (loop1,count,count,count);
  69.     END;
  70.     for loop1:=150 to 201 do BEGIN
  71.       count:=random (64);
  72.       pal (loop1,count,count,count);
  73.     END;
  74.   END;   { Do the static for a while }
  75.  
  76.   repeat
  77.     inc (count);
  78.     if count>10 then BEGIN
  79.       count:=0;
  80.       inc (count2);
  81.     END;
  82.     waitretrace;
  83.     for loop1:=99 to 150 do BEGIN
  84.       count3:=random (64-count2);
  85.       if count3<0 then count3:=0;
  86.       pal (loop1,count3,count3,count3);
  87.     END;
  88.     for loop1:=150 to 201 do BEGIN
  89.       count3:=random (64);
  90.       count3:=count3+count2;
  91.       if count3>63 then count3:=63;
  92.       pal (loop1,count3,count3,count3);
  93.     END;
  94.   until count2>63; { Static fade in Asphyxia logo }
  95.  
  96.   delay (500);
  97.   for loop1:=30 to 62 do BEGIN
  98.     line (0,loop1*2,319,loop1*2,0,vga);
  99.     delay (5);
  100.   END;
  101.   for loop1:=62 downto 30 do BEGIN
  102.     line (0,loop1*2+1,319,loop1*2+1,0,vga);
  103.     delay (5);
  104.   END;  { Erase logo with lines }
  105.   delay (1000);
  106.   while keypressed do readkey;
  107. END;
  108.  
  109.  
  110. {──────────────────────────────────────────────────────────────────────────}
  111. Procedure Fadeup;
  112.   { This fades up the pallette to white }
  113. VAR loop1,loop2:integer;
  114.     Tmp : Array [1..3] of byte;
  115. BEGIN
  116.   For loop1:=1 to 64 do BEGIN
  117.     WaitRetrace;
  118.     For loop2:=0 to 255 do BEGIN
  119.       Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]);
  120.       If Tmp[1]<63 then inc (Tmp[1]);
  121.       If Tmp[2]<63 then inc (Tmp[2]);
  122.       If Tmp[3]<63 then inc (Tmp[3]);
  123.       Pal (loop2,Tmp[1],Tmp[2],Tmp[3]);
  124.     END;
  125.   END;
  126. END;
  127.  
  128.  
  129. {──────────────────────────────────────────────────────────────────────────}
  130. Procedure FadeTo (name:string);
  131.   { This procedure fades the screen to name ... if you use this for yourself,
  132.     you will need to cut out the extra stuff I do in here specific to this
  133.     program }
  134. VAR loop1,loop2:integer;
  135.     tmp,pall2:array[0..255,1..3] of byte;
  136.     f:file;
  137. BEGIN
  138.   assign (f,name);
  139.   reset (f,1);
  140.   blockread (f,pall2,768);
  141.   close (f);
  142.   for loop1:=100 to 150 do BEGIN
  143.     pall2[loop1,1]:=loop1-100;
  144.     pall2[loop1,2]:=loop1-100;
  145.     pall2[loop1,3]:=loop1-100;
  146.   END;  { Set the background colors }
  147.   waitretrace;
  148.   for loop1:=0 to 255 do
  149.     getpal (loop1,tmp[loop1,1],tmp[loop1,2],tmp[loop1,3]);
  150.  
  151.   For loop1:=1 to 64 do BEGIN
  152.     For loop2:=0 to 255 do BEGIN
  153.       If Tmp[loop2,1]<Pall2[loop2,1] then inc (Tmp[loop2,1]);
  154.       If Tmp[loop2,2]<Pall2[loop2,2] then inc (Tmp[loop2,2]);
  155.       If Tmp[loop2,3]<Pall2[loop2,3] then inc (Tmp[loop2,3]);
  156.       If Tmp[loop2,1]>Pall2[loop2,1] then dec (Tmp[loop2,1]);
  157.       If Tmp[loop2,2]>Pall2[loop2,2] then dec (Tmp[loop2,2]);
  158.       If Tmp[loop2,3]>Pall2[loop2,3] then dec (Tmp[loop2,3]);
  159.     END;
  160.     WaitRetrace;
  161.     for loop2:=0 to 255 do
  162.       pal (loop2,tmp[loop2,1],tmp[loop2,2],tmp[loop2,3]);
  163.   END;
  164. END;
  165.  
  166.  
  167. {──────────────────────────────────────────────────────────────────────────}
  168. Procedure Show (x,y:integer;ch:string);
  169.   { This dumps string ch to screen at x,y in our main font }
  170. VAR loop1,loop2,loop3:integer;
  171. BEGIN
  172.   for loop3:=1 to length (ch) do
  173.     For loop1:=1 to 16 do
  174.       for loop2:=1 to 16 do
  175.         if Font^[ch[loop3],loop2,loop1]<>0 then
  176.           putpixel (x+loop1+(loop3*17),y+loop2,getpixel (x+loop1+(loop3*17),y+loop2,vaddr2)+51,VGA);
  177. END;
  178.  
  179.  
  180. {──────────────────────────────────────────────────────────────────────────}
  181. Procedure Eye_Popper;
  182.   { This fades up the colors used in our main font }
  183. VAR Loop1,loop2:integer;
  184.     tmp : array [1..3] of byte;
  185. BEGIN
  186.   if keypressed then exit;
  187.   for loop1:=1 to 63 do
  188.     for loop2:=1 to 8 do BEGIN
  189.       Waitretrace;
  190.       Getpal (loop2,tmp[1],tmp[2],tmp[3]);
  191.       if tmp[1]<63 then inc (tmp[1]);
  192.       if tmp[2]<63 then inc (tmp[2]);
  193.       if tmp[3]<63 then inc (tmp[3]);
  194.       pal (loop2,tmp[1],tmp[2],tmp[3]);
  195.     END;
  196.   for loop1:=151 to 200 do
  197.     pal (loop1,63,63,63);
  198. END;
  199.  
  200.  
  201. {──────────────────────────────────────────────────────────────────────────}
  202. Procedure FadeOutText;
  203.   { This fades out the colors of our main font to the colors of the background
  204.     static }
  205. VAR Loop1,loop2:integer;
  206.     tmp : array [1..3] of byte;
  207. BEGIN
  208.   if keypressed then exit;
  209.   for loop1:=1 to 63 do BEGIN
  210.     Waitretrace;
  211.     for loop2:=151 to 200 do BEGIN
  212.       Getpal (loop2,tmp[1],tmp[2],tmp[3]);
  213.       if tmp[1]>loop2-151 then dec (tmp[1]);
  214.       if tmp[2]>loop2-151 then dec (tmp[2]);
  215.       if tmp[3]>loop2-151 then dec (tmp[3]);
  216.       pal (loop2,tmp[1],tmp[2],tmp[3]);
  217.     END;
  218.   END;
  219.   delay (100);
  220. END;
  221.  
  222.  
  223. {──────────────────────────────────────────────────────────────────────────}
  224. Procedure Move_Em_Out (num:integer;del:byte);
  225.   { This procedure runs through each pixel that is active and moves it closer
  226.     to its destination }
  227. VAR loop2:integer;
  228. BEGIN
  229.   if del<>0 then delay (del);
  230.   for loop2:=1 to num do
  231.     if nextrow^[loop2].active then with nextrow^[loop2] do BEGIN
  232.       putpixel (herex shr sjump,herey shr sjump,
  233.                 getpixel (herex shr sjump,herey shr sjump,vaddr),vga);
  234.         { Restore old bacground }
  235.       herex:=herex-dx;
  236.       herey:=herey-dy;  { Move pixel one step closer }
  237.       putpixel (herex shr sjump,herey shr sjump,col,vga); { Put down pixel }
  238.       dec (num);
  239.       if num=0 then BEGIN
  240.         active:=false;
  241.         putpixel (herex shr sjump,herey shr sjump,col,vaddr);
  242.       END;  { If destination reached, deactivate }
  243.     END;
  244. END;
  245.  
  246.  
  247. {──────────────────────────────────────────────────────────────────────────}
  248. Procedure Doletter (msg : char; dx,dy : integer);
  249.   { This procedure activates the pixels necessary to draw a letter }
  250. VAR loop1,loop2:integer;
  251.     x,y : Integer;
  252. BEGIN
  253.   if keypressed then exit;
  254.   for loop2:=1 to 16 do BEGIN
  255.     for loop1:=1 to 16 do     { Our font is 16x16 }
  256.       if Font^[msg,loop1,loop2]<>0 then BEGIN { Don't do black pixels }
  257.         if dir then PosLoop:=PosLoop+1
  258.           else PosLoop:=PosLoop-1;
  259.         if PosLoop=315 then PosLoop:=1;
  260.         if PosLoop=0 then PosLoop:=314;
  261.         X:=pathx[PosLoop]+160;
  262.         y:=pathy[PosLoop]+100;     { Find point of origination }
  263.  
  264.         nextrow^ [counter].herex:=x shl sjump;
  265.         nextrow^ [counter].herey:=y shl sjump;
  266.           { This is where I am }
  267.         nextrow^ [counter].targx:=(dx+loop2) shl sjump;
  268.         nextrow^ [counter].targy:=(dy+loop1) shl sjump;
  269.           { This is where I want to be }
  270.         nextrow^ [counter].dx:=(nextrow^[counter].herex-nextrow^[counter].targx) div jump;
  271.         nextrow^ [counter].dy:=(nextrow^[counter].herey-nextrow^[counter].targy) div jump;
  272.           { This is how I get there }
  273.         nextrow^ [counter].col:=Font^[msg,loop1,loop2];
  274.         nextrow^ [counter].active:=TRUE;
  275.         nextrow^ [counter].num:=jump;
  276.         move_em_out(jump,6);
  277.  
  278.         inc (counter);
  279.         if counter=jump+1 then counter:=1;
  280.       END;
  281.   END;
  282. END;
  283.  
  284.  
  285.  
  286. {──────────────────────────────────────────────────────────────────────────}
  287. Procedure DoPic;
  288.   { This procedure morphs in the tank }
  289. VAR f:file;
  290.     ch:byte;
  291.     count,loop1,loop2:integer;
  292.     ourpal : array [0..255,1..3] of byte;
  293. BEGIN
  294.   cls (vaddr,0);
  295.   getmem (nextrow,sizeof(nextrow^));
  296.   GetMem(Vir2,64000);
  297.   Vaddr2 := Seg(Vir2^);
  298.   for loop2:=1 to 4095 do
  299.     nextrow^[loop2].active:=false;
  300.  
  301.   assign (f,'tut17.cel');
  302.   reset (f,1);
  303.   seek (f,32);
  304.   blockread (f,ourpal,768);
  305.   for loop1:=0 to 255 do
  306.     pal (loop1,ourpal[loop1,1],ourpal[loop1,2],ourpal[loop1,3]);
  307.   count:=1;
  308.   for loop2:=1 to 60 do
  309.     for loop1:=1 to 160 do BEGIN
  310.       blockread (f,ch,1);     { Go through the pic, and activate non-black
  311.                                 pixels }
  312.       if ch<>0 then BEGIN
  313.         nextrow^ [count].herex:=random (320) shl sjump;
  314.         nextrow^ [count].herey:=random (200) shl sjump;
  315.           { This is where I am }
  316.         nextrow^ [count].targx:=(loop1+80) shl sjump;
  317.         nextrow^ [count].targy:=(loop2+70) shl sjump;
  318.           { This is where I want to be }
  319.         nextrow^ [count].dx:=(nextrow^[count].herex-nextrow^[count].targx) div jump;
  320.         nextrow^ [count].dy:=(nextrow^[count].herey-nextrow^[count].targy) div jump;
  321.           { This is how I get there }
  322.         nextrow^ [count].col:=ch;
  323.         nextrow^ [count].active:=TRUE;
  324.         nextrow^ [count].num:=jump;
  325.         inc (count);
  326.       END;
  327.   END;
  328.   close (f);
  329.   for loop1:=0 to 64 do
  330.     move_em_out (count,0);  { Move pixels to targets }
  331.   delay (2000);
  332.   fadeup;
  333. END;
  334.  
  335. {──────────────────────────────────────────────────────────────────────────}
  336. Procedure Init;
  337. VAR f:file;
  338.     loop1,loop2:integer;
  339.     loopie:real;
  340. BEGIN
  341.   getmem (Font,sizeof(Font^));
  342.  
  343.   for loop2:=1 to jump do
  344.     nextrow^[loop2].active:=false;
  345.  
  346.   Assign(f,'gods.Fnt');
  347.   Reset(f,1);
  348.   Blockread(F,Font^,SizeOf(Font^));
  349.   Close(f);
  350.  
  351.   assign (f,'biostext.dat');
  352.   reset (f,1);
  353.   Blockread (f,scr,sizeof (scr));
  354.   close (f);
  355.  
  356.   counter:=1;
  357.   PosLoop:=1;
  358.   dir:=true;
  359.   loopie:=0;
  360.   for loop1:=1 to 314 do BEGIN
  361.     loopie:=loopie+0.02;
  362.     pathX[loop1]:=round(150*cos (loopie));
  363.     pathy[loop1]:=round(90*sin (loopie));
  364.   END;    { Generate our path of origination }
  365.   cls (vga,0);
  366.   cls (vaddr,0);
  367.   cls (vaddr2,0);
  368.   for loop1:=0 to 319 do
  369.     for loop2:=0 to 199 do
  370.       putpixel (loop1,loop2,random (50)+100,vaddr2); { Fill the screen with static }
  371.   flip (vaddr2,vaddr);
  372.   flip (vaddr,vga);
  373.   fadeto ('game01.col');
  374.   for loop1:=1 to 8 do
  375.     getpal (loop1,arbpal[loop1,1],arbpal[loop1,2],arbpal[loop1,3]);
  376. END;
  377.  
  378.  
  379. {──────────────────────────────────────────────────────────────────────────}
  380. Procedure Play;
  381. VAR loop1,loop2:integer;
  382.     message : Array [1..10] of string;
  383. BEGIN
  384.   DoPic;
  385.   init;
  386.   while keypressed do readkey;
  387.              {[                 ]}
  388.   message[1]:='';
  389.   message[2]:='';
  390.   message[3]:='   PIXEL TEXT   ';
  391.   message[4]:='';
  392.   message[5]:='   A  ROUTINE';
  393.   message[6]:='';
  394.   message[7]:='      BY...';
  395.   message[9]:='';
  396.  message[10]:='';
  397.   for loop2:=1 to 7 do BEGIN
  398.     For loop1:=1 to length (message[loop2]) do BEGIN
  399.       doletter (message[loop2][loop1],loop1*17,loop2*17);
  400.       dir:=not(dir);
  401.     END;
  402.     for loop1:=1 to jump do move_em_out(jump,6);
  403.   END;
  404.  
  405.   eye_popper;
  406.   For loop1:=1 to 7 do
  407.     show (0,loop1*17,message[loop1]);
  408.   fadeouttext;
  409.   flip (vaddr2,vaddr);
  410.   flip (vaddr,vga);
  411.  
  412.   for loop1:=1 to 8 do
  413.     pal (loop1,arbpal[loop1,1],arbpal[loop1,2],arbpal[loop1,3]);
  414.   message[1]:='   TUNING...';
  415.   For loop1:=1 to length (message[1]) do BEGIN
  416.     if message[1][loop1]='.' then for loop2:=1 to 20 do
  417.       move_em_out(jump,6);
  418.     doletter (message[1][loop1],loop1*17,100);
  419.     dir:=not(dir);
  420.   END;
  421.   for loop1:=1 to jump do move_em_out(jump,6);
  422.  
  423.   eye_popper;
  424.   show (0,100,message[1]);
  425.   fadeouttext;
  426.  
  427.   static;
  428.  
  429.   freemem (vir2,sizeof (vir2^));
  430. END;
  431.  
  432.  
  433. BEGIN
  434.   clrscr;
  435.   writeln ('Hi there ... welcome to the seventeenth Asphyxia VGA Trainer ... and');
  436.   writeln ('the last one on demo effects for a while ... I am going to be doing');
  437.   writeln ('more work on the theory aspect in future trainers.');
  438.   writeln;
  439.   writeln ('This is an effect I first saw in an Extreme demo, and features ''Pixel');
  440.   writeln ('Text'', with various dots forming letters. Also included are some crossfades');
  441.   writeln ('and a static routine.');
  442.   writeln;
  443.   writeln ('Check out the GFX3 unit for a faster putpixel...');
  444.   writeln;
  445.   writeln ('The tank was drawn by Fubar a while ago when he was starting to learn');
  446.   writeln ('3D Studio. The font I found somewhere on my hard drive.');
  447.   writeln;
  448.   writeln;
  449.   writeln ('Hit any key to continue ...');
  450.   readkey;
  451.   setmcga;
  452.   setupvirtual;
  453.   play;
  454.   settext;
  455.   shutdown;
  456.   Writeln ('All done. This concludes the seventeenth sample program in the ASPHYXIA');
  457.   Writeln ('Training series. You may reach DENTHOR under the names of GRANT');
  458.   Writeln ('SMITH/DENTHOR/ASPHYXIA on the ASPHYXIA BBS.I also occasinally read');
  459.   Writeln ('RSAProg, comp.lang.pascal and comp.sys.ibm.pc.demos. E-mail me at :');
  460.   Writeln ('    denthor@beastie.cs.und.ac.za');
  461.   Writeln ('The numbers are available in the main text. You may also write to me at:');
  462.   Writeln ('             Grant Smith');
  463.   Writeln ('             P.O. Box 270');
  464.   Writeln ('             Kloof');
  465.   Writeln ('             3640');
  466.   Writeln ('             Natal');
  467.   Writeln ('             South Africa');
  468.   Writeln ('I hope to hear from you soon!');
  469.   Writeln; Writeln;
  470.   Write   ('Hit any key to exit ...');
  471.   readkey;
  472. END.